VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ProjectFactory"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private this As Object

Public Sub init(factory As Object)
Set this = factory
End Sub
Public Function newProjectFixture(sponsor As Object) As ProjectFixture
Dim t As TypeLibInfo
Dim c As CoClassInfo

Set t = InterfaceInfoFromObject(sponsor).Parent
Set newProjectFixture = New ProjectFixture
newProjectFixture.init t.name

For Each c In t.CoClasses
    If BeginsWith(c.name, "test") Then
        newProjectFixture.add newClassFixture(c)
    End If
Next

End Function

Public Function newClassFixture(Class As CoClassInfo) As ClassFixture
Dim aFixture As New ClassFixture
''
'TODO
'Sort out the relationship between ClassDescriptor and ClassFixture
aFixture.init newClassDescriptor(Class)
Dim vname As Variant
Dim name As String
For Each vname In aFixture.description.names
    name = vname
    aFixture.add newMethodFixture(aFixture, name)
Next
Set newClassFixture = aFixture
End Function

Private Function newClassDescriptor(info As CoClassInfo) As ClassDescriptor
Dim desc As New ClassDescriptor
desc.init info.Parent.name, info.name
Dim MI As MemberInfo
For Each MI In info.DefaultInterface.Members
    If isSubNoParams(MI) Then
        If BeginsWith(MI.name, "test") Then
            desc.add MI.name
        ElseIf CompareStr(MI.name, "setup") Then
            desc.hasSetup = True
        ElseIf CompareStr(MI.name, "teardown") Then
            desc.hasTearDown = True
        End If
    ElseIf isFuncRetLong(MI) Then
        If CompareStr(MI.name, "NumOfAsserts") Then
            desc.hasNumOfAsserts = True
        End If
    End If
Next
Set newClassDescriptor = desc
End Function
Private Function newMethodFixture(aFixture As ClassFixture, name As String) As MethodFixture
Dim fixture As New MethodFixture

With aFixture
    fixture.init name    'desc.name
    If .description.hasSetup Then
        fixture.add newFineMethodCallerAlt(.holder, "setup")
    End If
    fixture.add newFineMethodCaller(.holder, name)
    If .description.hasTearDown Then
        fixture.add newFineMethodCaller(.holder, "teardown")
    End If
End With
Set newMethodFixture = fixture
End Function
Private Function isSubNoParams(MI As MemberInfo) As Boolean
isSubNoParams = (MI.DescKind = DESCKIND_FUNCDESC And _
                 MI.Parameters.Count = 0 And _
                 MI.ReturnType = VT_VOID)
End Function
Private Function isFuncRetLong(MI As MemberInfo) As Boolean
isFuncRetLong = (MI.DescKind = DESCKIND_FUNCDESC And _
                 MI.Parameters.Count = 0 And _
                 MI.ReturnType = VT_I4)
End Function
Private Function BeginsWith(ByVal str As String, ByVal prefix As String) As Boolean
Dim p As String
p = LCase(Left(str, Len(prefix)))
BeginsWith = (p = LCase(prefix))
End Function
Private Function CompareStr(ByVal str As String, ByVal RHS As String) As Boolean
CompareStr = (LCase(str) = LCase(RHS))
End Function



Public Function newFineMethodCaller(holder As Object, methodName As String) As Object
Dim fine As New FineMethodCaller
fine.init methodName, newMethodRunner(holder, methodName, fine)
Set newFineMethodCaller = fine
End Function
Public Function newFineMethodCallerAlt(holder As Object, methodName As String) As Object
Dim fine As New FineMethodCaller
fine.init methodName, newMethodRunnerAlt(holder, methodName, fine)
Set newFineMethodCallerAlt = fine
End Function


Public Function newMethodRunner(testcase As Object, name As String, host As Object) As Object
Dim callTestCase As Object
Dim timedMethod As Object
Set callTestCase = newMethodCaller(testcase, name)
Set timedMethod = this.newMethodTimer(callTestCase, host)
Set newMethodRunner = newMethodErrorHandler(timedMethod, host, host)
End Function

'' Changing newMethodRunnerAlt to add SetupErrorHandler
Public Function newMethodRunnerAlt(testcase As Object, name As String, host As Object) As Object
'Dim callTestCase As Object
'Set callTestCase = newMethodCaller(testcase, name)
'Set newMethodRunnerAlt = this.newMethodTimer(callTestCase, host)
Dim callTestCase As Object
Dim timedMethod As Object
Set callTestCase = newMethodCaller(testcase, name)
Set timedMethod = this.newMethodTimer(callTestCase, host)
Set newMethodRunnerAlt = newSetupErrorHandler(timedMethod, host, host)
End Function

''
'Note
'Only for use by other factories
'Clients should not call these methods
Friend Function newMethodCaller(forward As Object, name As String) As Object
Dim caller As New MethodCaller
caller.init forward, name
Set newMethodCaller = caller
End Function
Public Function newMethodTimer(forward As Object, host As Object) As Object
Dim caller As New MethodTimer
caller.init forward, host
Set newMethodTimer = caller
End Function
Private Function newMethodErrorHandler(forward As Object, noError As Object, errorHandler As Object) As Object
Dim caller As New MethodErrorHandler
caller.init forward, noError, errorHandler
Set newMethodErrorHandler = caller
End Function
Private Function newSetupErrorHandler(forward As Object, noError As Object, errorHandler As Object) As Object
Dim caller As New SetupErrorHandler
caller.init forward, noError, errorHandler
Set newSetupErrorHandler = caller
End Function
''
''

Private Sub Class_Initialize()
Set this = Me
End Sub
